home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl70b2.lha / tcl7.0b2 / tclExpr.c < prev    next >
C/C++ Source or Header  |  1993-07-19  |  53KB  |  1,959 lines
  1. /* 
  2.  * tclExpr.c --
  3.  *
  4.  *    This file contains the code to evaluate expressions for
  5.  *    Tcl.
  6.  *
  7.  *    This implementation of floating-point support was modelled
  8.  *    after an initial implementation by Bill Carpenter.
  9.  *
  10.  * Copyright (c) 1987-1993 The Regents of the University of California.
  11.  * All rights reserved.
  12.  *
  13.  * Permission is hereby granted, without written agreement and without
  14.  * license or royalty fees, to use, copy, modify, and distribute this
  15.  * software and its documentation for any purpose, provided that the
  16.  * above copyright notice and the following two paragraphs appear in
  17.  * all copies of this software.
  18.  * 
  19.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  20.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  21.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  22.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  23.  *
  24.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  25.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  26.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  27.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  28.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  29.  */
  30.  
  31. #ifndef lint
  32. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclExpr.c,v 1.56 93/07/19 15:21:13 ouster Exp $ SPRITE (Berkeley)";
  33. #endif
  34.  
  35. #include "tclInt.h"
  36. #ifdef NO_FLOAT_H
  37. #   include "compat/float.h"
  38. #else
  39. #   include <float.h>
  40. #endif
  41. #ifndef TCL_NO_MATH
  42. #include <math.h>
  43. #endif
  44.  
  45. /*
  46.  * The stuff below is a bit of a hack so that this file can be used
  47.  * in environments that include no UNIX, i.e. no errno.  Just define
  48.  * errno here.
  49.  */
  50.  
  51. #ifndef TCL_GENERIC_ONLY
  52. #include "tclUnix.h"
  53. #else
  54. int errno;
  55. #define EDOM 33
  56. #define ERANGE 34
  57. #endif
  58.  
  59. /*
  60.  * The data structure below is used to describe an expression value,
  61.  * which can be either an integer (the usual case), a double-precision
  62.  * floating-point value, or a string.  A given number has only one
  63.  * value at a time.
  64.  */
  65.  
  66. #define STATIC_STRING_SPACE 150
  67.  
  68. typedef struct {
  69.     long intValue;        /* Integer value, if any. */
  70.     double  doubleValue;    /* Floating-point value, if any. */
  71.     ParseValue pv;        /* Used to hold a string value, if any. */
  72.     char staticSpace[STATIC_STRING_SPACE];
  73.                 /* Storage for small strings;  large ones
  74.                  * are malloc-ed. */
  75.     int type;            /* Type of value:  TYPE_INT, TYPE_DOUBLE,
  76.                  * or TYPE_STRING. */
  77. } Value;
  78.  
  79. /*
  80.  * Valid values for type:
  81.  */
  82.  
  83. #define TYPE_INT    0
  84. #define TYPE_DOUBLE    1
  85. #define TYPE_STRING    2
  86.  
  87. /*
  88.  * The data structure below describes the state of parsing an expression.
  89.  * It's passed among the routines in this module.
  90.  */
  91.  
  92. typedef struct {
  93.     char *originalExpr;        /* The entire expression, as originally
  94.                  * passed to Tcl_ExprString et al. */
  95.     char *expr;            /* Position to the next character to be
  96.                  * scanned from the expression string. */
  97.     int token;            /* Type of the last token to be parsed from
  98.                  * expr.  See below for definitions.
  99.                  * Corresponds to the characters just
  100.                  * before expr. */
  101. } ExprInfo;
  102.  
  103. /*
  104.  * The token types are defined below.  In addition, there is a table
  105.  * associating a precedence with each operator.  The order of types
  106.  * is important.  Consult the code before changing it.
  107.  */
  108.  
  109. #define VALUE        0
  110. #define OPEN_PAREN    1
  111. #define CLOSE_PAREN    2
  112. #define COMMA        3
  113. #define END        4
  114. #define UNKNOWN        5
  115.  
  116. /*
  117.  * Binary operators:
  118.  */
  119.  
  120. #define MULT        8
  121. #define DIVIDE        9
  122. #define MOD        10
  123. #define PLUS        11
  124. #define MINUS        12
  125. #define LEFT_SHIFT    13
  126. #define RIGHT_SHIFT    14
  127. #define LESS        15
  128. #define GREATER        16
  129. #define LEQ        17
  130. #define GEQ        18
  131. #define EQUAL        19
  132. #define NEQ        20
  133. #define BIT_AND        21
  134. #define BIT_XOR        22
  135. #define BIT_OR        23
  136. #define AND        24
  137. #define OR        25
  138. #define QUESTY        26
  139. #define COLON        27
  140.  
  141. /*
  142.  * Unary operators:
  143.  */
  144.  
  145. #define    UNARY_MINUS    28
  146. #define NOT        29
  147. #define BIT_NOT        30
  148.  
  149. /*
  150.  * Precedence table.  The values for non-operator token types are ignored.
  151.  */
  152.  
  153. int precTable[] = {
  154.     0, 0, 0, 0, 0, 0, 0, 0,
  155.     11, 11, 11,                /* MULT, DIVIDE, MOD */
  156.     10, 10,                /* PLUS, MINUS */
  157.     9, 9,                /* LEFT_SHIFT, RIGHT_SHIFT */
  158.     8, 8, 8, 8,                /* LESS, GREATER, LEQ, GEQ */
  159.     7, 7,                /* EQUAL, NEQ */
  160.     6,                    /* BIT_AND */
  161.     5,                    /* BIT_XOR */
  162.     4,                    /* BIT_OR */
  163.     3,                    /* AND */
  164.     2,                    /* OR */
  165.     1, 1,                /* QUESTY, COLON */
  166.     12, 12, 12                /* UNARY_MINUS, NOT, BIT_NOT */
  167. };
  168.  
  169. /*
  170.  * Mapping from operator numbers to strings;  used for error messages.
  171.  */
  172.  
  173. char *operatorStrings[] = {
  174.     "VALUE", "(", ")", "END", "UNKNOWN", "5", "6", "7",
  175.     "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=",
  176.     ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":",
  177.     "-", "!", "~"
  178. };
  179.  
  180. /*
  181.  * The following slight modification to DBL_MAX is needed because of
  182.  * a compiler bug on Sprite (4/15/93).
  183.  */
  184.  
  185. #ifdef sprite
  186. #undef DBL_MAX
  187. #define DBL_MAX 1.797693134862316e+307
  188. #endif
  189.  
  190. /*
  191.  * Macros for testing floating-point values for certain special
  192.  * cases.  Test for not-a-number by comparing a value against
  193.  * itself;  test for infinity by comparing against the largest
  194.  * floating-point value.
  195.  */
  196.  
  197. #define IS_NAN(v) ((v) != (v))
  198. #ifdef DBL_MAX
  199. #   define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
  200. #else
  201. #   define IS_INF(v) 0
  202. #endif
  203.  
  204. /*
  205.  * The following global variable is use to signal matherr that Tcl
  206.  * is responsible for the arithmetic, so errors can be handled in a
  207.  * fashion appropriate for Tcl.  Zero means no Tcl math is in
  208.  * progress;  non-zero means Tcl is doing math.
  209.  */
  210.  
  211. int tcl_MathInProgress = 0;
  212.  
  213. /*
  214.  * The variable below serves no useful purpose except to generate
  215.  * a reference to matherr, so that the Tcl version of matherr is
  216.  * linked in rather than the system version.  Without this reference
  217.  * the need for matherr won't be discovered during linking until after
  218.  * libtcl.a has been processed, so Tcl's version won't be used.
  219.  */
  220.  
  221. #ifdef NEED_MATHERR
  222. extern int matherr();
  223. int (*tclMatherrPtr)() = matherr;
  224. #endif
  225.  
  226. /*
  227.  * Declarations for local procedures to this file:
  228.  */
  229.  
  230. static int        ExprAbsFunc _ANSI_ARGS_((ClientData clientData,
  231.                 Tcl_Interp *interp, Tcl_Value *args,
  232.                 Tcl_Value *resultPtr));
  233. static int        ExprBinaryFunc _ANSI_ARGS_((ClientData clientData,
  234.                 Tcl_Interp *interp, Tcl_Value *args,
  235.                 Tcl_Value *resultPtr));
  236. static int        ExprDoubleFunc _ANSI_ARGS_((ClientData clientData,
  237.                 Tcl_Interp *interp, Tcl_Value *args,
  238.                 Tcl_Value *resultPtr));
  239. static void        ExprFloatError _ANSI_ARGS_((Tcl_Interp *interp,
  240.                 double value));
  241. static int        ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp,
  242.                 ExprInfo *infoPtr, int prec, Value *valuePtr));
  243. static int        ExprIntFunc _ANSI_ARGS_((ClientData clientData,
  244.                 Tcl_Interp *interp, Tcl_Value *args,
  245.                 Tcl_Value *resultPtr));
  246. static int        ExprLex _ANSI_ARGS_((Tcl_Interp *interp,
  247.                 ExprInfo *infoPtr, Value *valuePtr));
  248. static void        ExprMakeString _ANSI_ARGS_((Tcl_Interp *interp,
  249.                 Value *valuePtr));
  250. static int        ExprMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
  251.                 ExprInfo *infoPtr, Value *valuePtr));
  252. static int        ExprParseString _ANSI_ARGS_((Tcl_Interp *interp,
  253.                 char *string, Value *valuePtr));
  254. static int        ExprRoundFunc _ANSI_ARGS_((ClientData clientData,
  255.                 Tcl_Interp *interp, Tcl_Value *args,
  256.                 Tcl_Value *resultPtr));
  257. static int        ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp,
  258.                 char *string, Value *valuePtr));
  259. static int        ExprUnaryFunc _ANSI_ARGS_((ClientData clientData,
  260.                 Tcl_Interp *interp, Tcl_Value *args,
  261.                 Tcl_Value *resultPtr));
  262.  
  263. /*
  264.  * Built-in math functions:
  265.  */
  266.  
  267. typedef struct {
  268.     char *name;            /* Name of function. */
  269.     int numArgs;        /* Number of arguments for function. */
  270.     Tcl_ValueType argTypes[MAX_MATH_ARGS];
  271.                 /* Acceptable types for each argument. */
  272.     Tcl_MathProc *proc;        /* Procedure that implements this function. */
  273.     ClientData clientData;    /* Additional argument to pass to the function
  274.                  * when invoking it. */
  275. } BuiltinFunc;
  276.  
  277. static BuiltinFunc funcTable[] = {
  278. #ifndef TCL_NO_MATH
  279.     {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
  280.     {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
  281.     {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
  282.     {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
  283.     {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
  284.     {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
  285.     {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
  286.     {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
  287.     {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
  288.     {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
  289.     {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
  290.     {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
  291.     {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
  292.     {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
  293.     {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
  294.     {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
  295.     {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
  296.     {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
  297.     {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
  298. #endif
  299.     {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
  300.     {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
  301.     {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
  302.     {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
  303.  
  304.     {0},
  305. };
  306.  
  307. /*
  308.  *--------------------------------------------------------------
  309.  *
  310.  * ExprParseString --
  311.  *
  312.  *    Given a string (such as one coming from command or variable
  313.  *    substitution), make a Value based on the string.  The value
  314.  *    will be a floating-point or integer, if possible, or else it
  315.  *    will just be a copy of the string.
  316.  *
  317.  * Results:
  318.  *    TCL_OK is returned under normal circumstances, and TCL_ERROR
  319.  *    is returned if a floating-point overflow or underflow occurred
  320.  *    while reading in a number.  The value at *valuePtr is modified
  321.  *    to hold a number, if possible.
  322.  *
  323.  * Side effects:
  324.  *    None.
  325.  *
  326.  *--------------------------------------------------------------
  327.  */
  328.  
  329. static int
  330. ExprParseString(interp, string, valuePtr)
  331.     Tcl_Interp *interp;        /* Where to store error message. */
  332.     char *string;        /* String to turn into value. */
  333.     Value *valuePtr;        /* Where to store value information. 
  334.                  * Caller must have initialized pv field. */
  335. {
  336.     char *term, *p;
  337.  
  338.     if (*string != 0) {
  339.     valuePtr->type = TYPE_INT;
  340.     errno = 0;
  341.  
  342.     /*
  343.      * Note: use strtoul instead of strtol for integer conversions
  344.      * to allow full-size unsigned numbers, but don't depend on
  345.      * strtoul to handle sign characters;  it won't in some
  346.      * implementations.
  347.      */
  348.  
  349.     for (p = string; isspace(*p); p++) {
  350.         /* Empty loop body. */
  351.     }
  352.     if (*p == '-') {
  353.         valuePtr->intValue = -strtoul(p+1, &term, 0);
  354.     } else if (*p == '+') {
  355.         valuePtr->intValue = strtoul(p+1, &term, 0);
  356.     } else {
  357.         valuePtr->intValue = strtoul(p, &term, 0);
  358.     }
  359.     if (errno == ERANGE) {
  360.         /*
  361.          * This procedure is sometimes called with string in
  362.          * interp->result, so we have to clear the result before
  363.          * logging an error message.
  364.          */
  365.  
  366.         Tcl_ResetResult(interp);
  367.         interp->result = "integer value too large to represent";
  368.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result,
  369.             (char *) NULL);
  370.         return TCL_ERROR;
  371.     }
  372.     if (*term == '\0') {
  373.         return TCL_OK;
  374.     }
  375.     errno = 0;
  376.     valuePtr->doubleValue = strtod(p, &term);
  377.     if ((term != p) && (*term == '\0')) {
  378.         if (errno != 0) {
  379.         Tcl_ResetResult(interp);
  380.         ExprFloatError(interp, valuePtr->doubleValue);
  381.         return TCL_ERROR;
  382.         }
  383.         valuePtr->type = TYPE_DOUBLE;
  384.         return TCL_OK;
  385.     }
  386.     }
  387.  
  388.     /*
  389.      * Not a valid number.  Save a string value (but don't do anything
  390.      * if it's already the value).
  391.      */
  392.  
  393.     valuePtr->type = TYPE_STRING;
  394.     if (string != valuePtr->pv.buffer) {
  395.     int length, shortfall;
  396.  
  397.     length = strlen(string);
  398.     valuePtr->pv.next = valuePtr->pv.buffer;
  399.     shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer);
  400.     if (shortfall > 0) {
  401.         (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
  402.     }
  403.     strcpy(valuePtr->pv.buffer, string);
  404.     }
  405.     return TCL_OK;
  406. }
  407.  
  408. /*
  409.  *----------------------------------------------------------------------
  410.  *
  411.  * ExprLex --
  412.  *
  413.  *    Lexical analyzer for expression parser:  parses a single value,
  414.  *    operator, or other syntactic element from an expression string.
  415.  *
  416.  * Results:
  417.  *    TCL_OK is returned unless an error occurred while doing lexical
  418.  *    analysis or executing an embedded command.  In that case a
  419.  *    standard Tcl error is returned, using interp->result to hold
  420.  *    an error message.  In the event of a successful return, the token
  421.  *    and field in infoPtr is updated to refer to the next symbol in
  422.  *    the expression string, and the expr field is advanced past that
  423.  *    token;  if the token is a value, then the value is stored at
  424.  *    valuePtr.
  425.  *
  426.  * Side effects:
  427.  *    None.
  428.  *
  429.  *----------------------------------------------------------------------
  430.  */
  431.  
  432. static int
  433. ExprLex(interp, infoPtr, valuePtr)
  434.     Tcl_Interp *interp;            /* Interpreter to use for error
  435.                      * reporting. */
  436.     register ExprInfo *infoPtr;        /* Describes the state of the parse. */
  437.     register Value *valuePtr;        /* Where to store value, if that is
  438.                      * what's parsed from string.  Caller
  439.                      * must have initialized pv field
  440.                      * correctly. */
  441. {
  442.     register char *p;
  443.     char *var, *term;
  444.     int result;
  445.  
  446.     p = infoPtr->expr;
  447.     while (isspace(*p)) {
  448.     p++;
  449.     }
  450.     if (*p == 0) {
  451.     infoPtr->token = END;
  452.     infoPtr->expr = p;
  453.     return TCL_OK;
  454.     }
  455.  
  456.     /*
  457.      * First try to parse the token as an integer or floating-point number.
  458.      * A couple of tricky points:
  459.      *
  460.      * 1. Can't just check for leading digits to see if there's a number
  461.      *    there, because it could be a special value like "NaN".
  462.      * 2. Don't want to check for a number if the first character is "+"
  463.      *    or "-".  If we do, we might treat a binary operator as unary
  464.      *    by mistake, which will eventually cause a syntax error.
  465.      */
  466.  
  467.     if ((*p != '+')  && (*p != '-')) {
  468.     errno = 0;
  469.     valuePtr->intValue = strtoul(p, &term, 0);
  470.     if ((term == p) || (*term == '.') || (*term == 'e') || (*term == 'E')) {
  471.         char *term2;
  472.     
  473.         /*
  474.          * The code here is a bit tricky:  we want to use a floating-point
  475.          * number if there is one, but if there isn't then fall through to
  476.          * use the integer that was already parsed, if there was one.
  477.          */
  478.     
  479.         errno = 0;
  480.         valuePtr->doubleValue = strtod(p, &term2);
  481.         if (term2 != p) {
  482.         if (errno != 0) {
  483.             ExprFloatError(interp, valuePtr->doubleValue);
  484.             return TCL_ERROR;
  485.         }
  486.         infoPtr->token = VALUE;
  487.         infoPtr->expr = term2;
  488.         valuePtr->type = TYPE_DOUBLE;
  489.         return TCL_OK;
  490.         }
  491.         if (term != p) {
  492.         interp->result = "poorly-formed floating-point value";
  493.         return TCL_ERROR;
  494.         }
  495.     }
  496.     if (term != p) {
  497.         /*
  498.          * No floating-point number, but there is an integer.
  499.          */
  500.     
  501.         if (errno == ERANGE) {
  502.         interp->result = "integer value too large to represent";
  503.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result,
  504.             (char *) NULL);
  505.         return TCL_ERROR;
  506.         }
  507.         infoPtr->token = VALUE;
  508.         infoPtr->expr = term;
  509.         valuePtr->type = TYPE_INT;
  510.         return TCL_OK;
  511.     }
  512.     }
  513.  
  514.     infoPtr->expr = p+1;
  515.     switch (*p) {
  516.     case '$':
  517.  
  518.         /*
  519.          * Variable.  Fetch its value, then see if it makes sense
  520.          * as an integer or floating-point number.
  521.          */
  522.  
  523.         infoPtr->token = VALUE;
  524.         var = Tcl_ParseVar(interp, p, &infoPtr->expr);
  525.         if (var == NULL) {
  526.         return TCL_ERROR;
  527.         }
  528.         Tcl_ResetResult(interp);
  529.         if (((Interp *) interp)->noEval) {
  530.         valuePtr->type = TYPE_INT;
  531.         valuePtr->intValue = 0;
  532.         return TCL_OK;
  533.         }
  534.         return ExprParseString(interp, var, valuePtr);
  535.  
  536.     case '[':
  537.         infoPtr->token = VALUE;
  538.         ((Interp *) interp)->evalFlags = TCL_BRACKET_TERM;
  539.         result = Tcl_Eval(interp, p+1);
  540.         infoPtr->expr = ((Interp *) interp)->termPtr;
  541.         if (result != TCL_OK) {
  542.         return result;
  543.         }
  544.         infoPtr->expr++;
  545.         if (((Interp *) interp)->noEval) {
  546.         valuePtr->type = TYPE_INT;
  547.         valuePtr->intValue = 0;
  548.         Tcl_ResetResult(interp);
  549.         return TCL_OK;
  550.         }
  551.         result = ExprParseString(interp, interp->result, valuePtr);
  552.         if (result != TCL_OK) {
  553.         return result;
  554.         }
  555.         Tcl_ResetResult(interp);
  556.         return TCL_OK;
  557.  
  558.     case '"':
  559.         infoPtr->token = VALUE;
  560.         result = TclParseQuotes(interp, infoPtr->expr, '"', 0,
  561.             &infoPtr->expr, &valuePtr->pv);
  562.         if (result != TCL_OK) {
  563.         return result;
  564.         }
  565.         Tcl_ResetResult(interp);
  566.         return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
  567.  
  568.     case '{':
  569.         infoPtr->token = VALUE;
  570.         result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr,
  571.             &valuePtr->pv);
  572.         if (result != TCL_OK) {
  573.         return result;
  574.         }
  575.         Tcl_ResetResult(interp);
  576.         return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
  577.  
  578.     case '(':
  579.         infoPtr->token = OPEN_PAREN;
  580.         return TCL_OK;
  581.  
  582.     case ')':
  583.         infoPtr->token = CLOSE_PAREN;
  584.         return TCL_OK;
  585.  
  586.     case ',':
  587.         infoPtr->token = COMMA;
  588.         return TCL_OK;
  589.  
  590.     case '*':
  591.         infoPtr->token = MULT;
  592.         return TCL_OK;
  593.  
  594.     case '/':
  595.         infoPtr->token = DIVIDE;
  596.         return TCL_OK;
  597.  
  598.     case '%':
  599.         infoPtr->token = MOD;
  600.         return TCL_OK;
  601.  
  602.     case '+':
  603.         infoPtr->token = PLUS;
  604.         return TCL_OK;
  605.  
  606.     case '-':
  607.         infoPtr->token = MINUS;
  608.         return TCL_OK;
  609.  
  610.     case '?':
  611.         infoPtr->token = QUESTY;
  612.         return TCL_OK;
  613.  
  614.     case ':':
  615.         infoPtr->token = COLON;
  616.         return TCL_OK;
  617.  
  618.     case '<':
  619.         switch (p[1]) {
  620.         case '<':
  621.             infoPtr->expr = p+2;
  622.             infoPtr->token = LEFT_SHIFT;
  623.             break;
  624.         case '=':
  625.             infoPtr->expr = p+2;
  626.             infoPtr->token = LEQ;
  627.             break;
  628.         default:
  629.             infoPtr->token = LESS;
  630.             break;
  631.         }
  632.         return TCL_OK;
  633.  
  634.     case '>':
  635.         switch (p[1]) {
  636.         case '>':
  637.             infoPtr->expr = p+2;
  638.             infoPtr->token = RIGHT_SHIFT;
  639.             break;
  640.         case '=':
  641.             infoPtr->expr = p+2;
  642.             infoPtr->token = GEQ;
  643.             break;
  644.         default:
  645.             infoPtr->token = GREATER;
  646.             break;
  647.         }
  648.         return TCL_OK;
  649.  
  650.     case '=':
  651.         if (p[1] == '=') {
  652.         infoPtr->expr = p+2;
  653.         infoPtr->token = EQUAL;
  654.         } else {
  655.         infoPtr->token = UNKNOWN;
  656.         }
  657.         return TCL_OK;
  658.  
  659.     case '!':
  660.         if (p[1] == '=') {
  661.         infoPtr->expr = p+2;
  662.         infoPtr->token = NEQ;
  663.         } else {
  664.         infoPtr->token = NOT;
  665.         }
  666.         return TCL_OK;
  667.  
  668.     case '&':
  669.         if (p[1] == '&') {
  670.         infoPtr->expr = p+2;
  671.         infoPtr->token = AND;
  672.         } else {
  673.         infoPtr->token = BIT_AND;
  674.         }
  675.         return TCL_OK;
  676.  
  677.     case '^':
  678.         infoPtr->token = BIT_XOR;
  679.         return TCL_OK;
  680.  
  681.     case '|':
  682.         if (p[1] == '|') {
  683.         infoPtr->expr = p+2;
  684.         infoPtr->token = OR;
  685.         } else {
  686.         infoPtr->token = BIT_OR;
  687.         }
  688.         return TCL_OK;
  689.  
  690.     case '~':
  691.         infoPtr->token = BIT_NOT;
  692.         return TCL_OK;
  693.  
  694.     default:
  695.         if (isalpha(*p)) {
  696.         infoPtr->expr = p;
  697.         return ExprMathFunc(interp, infoPtr, valuePtr);
  698.         }
  699.         infoPtr->expr = p+1;
  700.         infoPtr->token = UNKNOWN;
  701.         return TCL_OK;
  702.     }
  703. }
  704.  
  705. /*
  706.  *----------------------------------------------------------------------
  707.  *
  708.  * ExprGetValue --
  709.  *
  710.  *    Parse a "value" from the remainder of the expression in infoPtr.
  711.  *
  712.  * Results:
  713.  *    Normally TCL_OK is returned.  The value of the expression is
  714.  *    returned in *valuePtr.  If an error occurred, then interp->result
  715.  *    contains an error message and TCL_ERROR is returned.
  716.  *    InfoPtr->token will be left pointing to the token AFTER the
  717.  *    expression, and infoPtr->expr will point to the character just
  718.  *    after the terminating token.
  719.  *
  720.  * Side effects:
  721.  *    None.
  722.  *
  723.  *----------------------------------------------------------------------
  724.  */
  725.  
  726. static int
  727. ExprGetValue(interp, infoPtr, prec, valuePtr)
  728.     Tcl_Interp *interp;            /* Interpreter to use for error
  729.                      * reporting. */
  730.     register ExprInfo *infoPtr;        /* Describes the state of the parse
  731.                      * just before the value (i.e. ExprLex
  732.                      * will be called to get first token
  733.                      * of value). */
  734.     int prec;                /* Treat any un-parenthesized operator
  735.                      * with precedence <= this as the end
  736.                      * of the expression. */
  737.     Value *valuePtr;            /* Where to store the value of the
  738.                      * expression.   Caller must have
  739.                      * initialized pv field. */
  740. {
  741.     Interp *iPtr = (Interp *) interp;
  742.     Value value2;            /* Second operand for current
  743.                      * operator.  */
  744.     int operator;            /* Current operator (either unary
  745.                      * or binary). */
  746.     int badType;            /* Type of offending argument;  used
  747.                      * for error messages. */
  748.     int gotOp;                /* Non-zero means already lexed the
  749.                      * operator (while picking up value
  750.                      * for unary operator).  Don't lex
  751.                      * again. */
  752.     int result;
  753.  
  754.     /*
  755.      * There are two phases to this procedure.  First, pick off an initial
  756.      * value.  Then, parse (binary operator, value) pairs until done.
  757.      */
  758.  
  759.     gotOp = 0;
  760.     value2.pv.buffer = value2.pv.next = value2.staticSpace;
  761.     value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1;
  762.     value2.pv.expandProc = TclExpandParseValue;
  763.     value2.pv.clientData = (ClientData) NULL;
  764.     result = ExprLex(interp, infoPtr, valuePtr);
  765.     if (result != TCL_OK) {
  766.     goto done;
  767.     }
  768.     if (infoPtr->token == OPEN_PAREN) {
  769.  
  770.     /*
  771.      * Parenthesized sub-expression.
  772.      */
  773.  
  774.     result = ExprGetValue(interp, infoPtr, -1, valuePtr);
  775.     if (result != TCL_OK) {
  776.         goto done;
  777.     }
  778.     if (infoPtr->token != CLOSE_PAREN) {
  779.         Tcl_AppendResult(interp, "unmatched parentheses in expression \"",
  780.             infoPtr->originalExpr, "\"", (char *) NULL);
  781.         result = TCL_ERROR;
  782.         goto done;
  783.     }
  784.     } else {
  785.     if (infoPtr->token == MINUS) {
  786.         infoPtr->token = UNARY_MINUS;
  787.     }
  788.     if (infoPtr->token >= UNARY_MINUS) {
  789.  
  790.         /*
  791.          * Process unary operators.
  792.          */
  793.  
  794.         operator = infoPtr->token;
  795.         result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token],
  796.             valuePtr);
  797.         if (result != TCL_OK) {
  798.         goto done;
  799.         }
  800.         switch (operator) {
  801.         case UNARY_MINUS:
  802.             if (valuePtr->type == TYPE_INT) {
  803.             valuePtr->intValue = -valuePtr->intValue;
  804.             } else if (valuePtr->type == TYPE_DOUBLE){
  805.             valuePtr->doubleValue = -valuePtr->doubleValue;
  806.             } else {
  807.             badType = valuePtr->type;
  808.             goto illegalType;
  809.             } 
  810.             break;
  811.         case NOT:
  812.             if (valuePtr->type == TYPE_INT) {
  813.             valuePtr->intValue = !valuePtr->intValue;
  814.             } else if (valuePtr->type == TYPE_DOUBLE) {
  815.             /*
  816.              * Theoretically, should be able to use
  817.              * "!valuePtr->intValue", but apparently some
  818.              * compilers can't handle it.
  819.              */
  820.             if (valuePtr->doubleValue == 0.0) {
  821.                 valuePtr->intValue = 1;
  822.             } else {
  823.                 valuePtr->intValue = 0;
  824.             }
  825.             valuePtr->type = TYPE_INT;
  826.             } else {
  827.             badType = valuePtr->type;
  828.             goto illegalType;
  829.             }
  830.             break;
  831.         case BIT_NOT:
  832.             if (valuePtr->type == TYPE_INT) {
  833.             valuePtr->intValue = ~valuePtr->intValue;
  834.             } else {
  835.             badType  = valuePtr->type;
  836.             goto illegalType;
  837.             }
  838.             break;
  839.         }
  840.         gotOp = 1;
  841.     } else if (infoPtr->token != VALUE) {
  842.         goto syntaxError;
  843.     }
  844.     }
  845.  
  846.     /*
  847.      * Got the first operand.  Now fetch (operator, operand) pairs.
  848.      */
  849.  
  850.     if (!gotOp) {
  851.     result = ExprLex(interp, infoPtr, &value2);
  852.     if (result != TCL_OK) {
  853.         goto done;
  854.     }
  855.     }
  856.     while (1) {
  857.     operator = infoPtr->token;
  858.     value2.pv.next = value2.pv.buffer;
  859.     if ((operator < MULT) || (operator >= UNARY_MINUS)) {
  860.         if ((operator == END) || (operator == CLOSE_PAREN)
  861.             || (operator == COMMA)) {
  862.         result = TCL_OK;
  863.         goto done;
  864.         } else {
  865.         goto syntaxError;
  866.         }
  867.     }
  868.     if (precTable[operator] <= prec) {
  869.         result = TCL_OK;
  870.         goto done;
  871.     }
  872.  
  873.     /*
  874.      * If we're doing an AND or OR and the first operand already
  875.      * determines the result, don't execute anything in the
  876.      * second operand:  just parse.  Same style for ?: pairs.
  877.      */
  878.  
  879.     if ((operator == AND) || (operator == OR) || (operator == QUESTY)) {
  880.         if (valuePtr->type == TYPE_DOUBLE) {
  881.         valuePtr->intValue = valuePtr->doubleValue != 0;
  882.         valuePtr->type = TYPE_INT;
  883.         } else if (valuePtr->type == TYPE_STRING) {
  884.         badType = TYPE_STRING;
  885.         goto illegalType;
  886.         }
  887.         if (((operator == AND) && !valuePtr->intValue)
  888.             || ((operator == OR) && valuePtr->intValue)) {
  889.         iPtr->noEval++;
  890.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  891.             &value2);
  892.         iPtr->noEval--;
  893.         } else if (operator == QUESTY) {
  894.         if (valuePtr->intValue != 0) {
  895.             valuePtr->pv.next = valuePtr->pv.buffer;
  896.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  897.                 valuePtr);
  898.             if (result != TCL_OK) {
  899.             goto done;
  900.             }
  901.             if (infoPtr->token != COLON) {
  902.             goto syntaxError;
  903.             }
  904.             value2.pv.next = value2.pv.buffer;
  905.             iPtr->noEval++;
  906.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  907.                 &value2);
  908.             iPtr->noEval--;
  909.         } else {
  910.             iPtr->noEval++;
  911.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  912.                 &value2);
  913.             iPtr->noEval--;
  914.             if (result != TCL_OK) {
  915.             goto done;
  916.             }
  917.             if (infoPtr->token != COLON) {
  918.             goto syntaxError;
  919.             }
  920.             valuePtr->pv.next = valuePtr->pv.buffer;
  921.             result = ExprGetValue(interp, infoPtr, precTable[operator],
  922.                 valuePtr);
  923.         }
  924.         } else {
  925.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  926.             &value2);
  927.         }
  928.     } else {
  929.         result = ExprGetValue(interp, infoPtr, precTable[operator],
  930.             &value2);
  931.     }
  932.     if (result != TCL_OK) {
  933.         goto done;
  934.     }
  935.     if ((infoPtr->token < MULT) && (infoPtr->token != VALUE)
  936.         && (infoPtr->token != END) && (infoPtr->token != COMMA)
  937.         && (infoPtr->token != CLOSE_PAREN)) {
  938.         goto syntaxError;
  939.     }
  940.  
  941.     /*
  942.      * At this point we've got two values and an operator.  Check
  943.      * to make sure that the particular data types are appropriate
  944.      * for the particular operator, and perform type conversion
  945.      * if necessary.
  946.      */
  947.  
  948.     switch (operator) {
  949.  
  950.         /*
  951.          * For the operators below, no strings are allowed and
  952.          * ints get converted to floats if necessary.
  953.          */
  954.  
  955.         case MULT: case DIVIDE: case PLUS: case MINUS:
  956.         if ((valuePtr->type == TYPE_STRING)
  957.             || (value2.type == TYPE_STRING)) {
  958.             badType = TYPE_STRING;
  959.             goto illegalType;
  960.         }
  961.         if (valuePtr->type == TYPE_DOUBLE) {
  962.             if (value2.type == TYPE_INT) {
  963.             value2.doubleValue = value2.intValue;
  964.             value2.type = TYPE_DOUBLE;
  965.             }
  966.         } else if (value2.type == TYPE_DOUBLE) {
  967.             if (valuePtr->type == TYPE_INT) {
  968.             valuePtr->doubleValue = valuePtr->intValue;
  969.             valuePtr->type = TYPE_DOUBLE;
  970.             }
  971.         }
  972.         break;
  973.  
  974.         /*
  975.          * For the operators below, only integers are allowed.
  976.          */
  977.  
  978.         case MOD: case LEFT_SHIFT: case RIGHT_SHIFT:
  979.         case BIT_AND: case BIT_XOR: case BIT_OR:
  980.          if (valuePtr->type != TYPE_INT) {
  981.              badType = valuePtr->type;
  982.              goto illegalType;
  983.          } else if (value2.type != TYPE_INT) {
  984.              badType = value2.type;
  985.              goto illegalType;
  986.          }
  987.          break;
  988.  
  989.         /*
  990.          * For the operators below, any type is allowed but the
  991.          * two operands must have the same type.  Convert integers
  992.          * to floats and either to strings, if necessary.
  993.          */
  994.  
  995.         case LESS: case GREATER: case LEQ: case GEQ:
  996.         case EQUAL: case NEQ:
  997.         if (valuePtr->type == TYPE_STRING) {
  998.             if (value2.type != TYPE_STRING) {
  999.             ExprMakeString(interp, &value2);
  1000.             }
  1001.         } else if (value2.type == TYPE_STRING) {
  1002.             if (valuePtr->type != TYPE_STRING) {
  1003.             ExprMakeString(interp, valuePtr);
  1004.             }
  1005.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1006.             if (value2.type == TYPE_INT) {
  1007.             value2.doubleValue = value2.intValue;
  1008.             value2.type = TYPE_DOUBLE;
  1009.             }
  1010.         } else if (value2.type == TYPE_DOUBLE) {
  1011.              if (valuePtr->type == TYPE_INT) {
  1012.             valuePtr->doubleValue = valuePtr->intValue;
  1013.             valuePtr->type = TYPE_DOUBLE;
  1014.             }
  1015.         }
  1016.         break;
  1017.  
  1018.         /*
  1019.          * For the operators below, no strings are allowed, but
  1020.          * no int->double conversions are performed.
  1021.          */
  1022.  
  1023.         case AND: case OR:
  1024.         if (valuePtr->type == TYPE_STRING) {
  1025.             badType = valuePtr->type;
  1026.             goto illegalType;
  1027.         }
  1028.         if (value2.type == TYPE_STRING) {
  1029.             badType = value2.type;
  1030.             goto illegalType;
  1031.         }
  1032.         break;
  1033.  
  1034.         /*
  1035.          * For the operators below, type and conversions are
  1036.          * irrelevant:  they're handled elsewhere.
  1037.          */
  1038.  
  1039.         case QUESTY: case COLON:
  1040.         break;
  1041.  
  1042.         /*
  1043.          * Any other operator is an error.
  1044.          */
  1045.  
  1046.         default:
  1047.         interp->result = "unknown operator in expression";
  1048.         result = TCL_ERROR;
  1049.         goto done;
  1050.     }
  1051.  
  1052.     /*
  1053.      * If necessary, convert one of the operands to the type
  1054.      * of the other.  If the operands are incompatible with
  1055.      * the operator (e.g. "+" on strings) then return an
  1056.      * error.
  1057.      */
  1058.  
  1059.     switch (operator) {
  1060.         case MULT:
  1061.         if (valuePtr->type == TYPE_INT) {
  1062.             valuePtr->intValue *= value2.intValue;
  1063.         } else {
  1064.             valuePtr->doubleValue *= value2.doubleValue;
  1065.         }
  1066.         break;
  1067.         case DIVIDE:
  1068.         if (valuePtr->type == TYPE_INT) {
  1069.             if (value2.intValue == 0) {
  1070.             divideByZero:
  1071.             interp->result = "divide by zero";
  1072.             Tcl_SetErrorCode(interp, "ARITH", "DIVZERO",
  1073.                 interp->result, (char *) NULL);
  1074.             result = TCL_ERROR;
  1075.             goto done;
  1076.             }
  1077.             valuePtr->intValue /= value2.intValue;
  1078.         } else {
  1079.             if (value2.doubleValue == 0.0) {
  1080.             goto divideByZero;
  1081.             }
  1082.             valuePtr->doubleValue /= value2.doubleValue;
  1083.         }
  1084.         break;
  1085.         case MOD:
  1086.         if (value2.intValue == 0) {
  1087.             goto divideByZero;
  1088.         }
  1089.         valuePtr->intValue %= value2.intValue;
  1090.         break;
  1091.         case PLUS:
  1092.         if (valuePtr->type == TYPE_INT) {
  1093.             valuePtr->intValue += value2.intValue;
  1094.         } else {
  1095.             valuePtr->doubleValue += value2.doubleValue;
  1096.         }
  1097.         break;
  1098.         case MINUS:
  1099.         if (valuePtr->type == TYPE_INT) {
  1100.             valuePtr->intValue -= value2.intValue;
  1101.         } else {
  1102.             valuePtr->doubleValue -= value2.doubleValue;
  1103.         }
  1104.         break;
  1105.         case LEFT_SHIFT:
  1106.         valuePtr->intValue <<= value2.intValue;
  1107.         break;
  1108.         case RIGHT_SHIFT:
  1109.         /*
  1110.          * The following code is a bit tricky:  it ensures that
  1111.          * right shifts propagate the sign bit even on machines
  1112.          * where ">>" won't do it by default.
  1113.          */
  1114.  
  1115.         if (valuePtr->intValue < 0) {
  1116.             valuePtr->intValue =
  1117.                 ~((~valuePtr->intValue) >> value2.intValue);
  1118.         } else {
  1119.             valuePtr->intValue >>= value2.intValue;
  1120.         }
  1121.         break;
  1122.         case LESS:
  1123.         if (valuePtr->type == TYPE_INT) {
  1124.             valuePtr->intValue =
  1125.             valuePtr->intValue < value2.intValue;
  1126.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1127.             valuePtr->intValue =
  1128.             valuePtr->doubleValue < value2.doubleValue;
  1129.         } else {
  1130.             valuePtr->intValue =
  1131.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0;
  1132.         }
  1133.         valuePtr->type = TYPE_INT;
  1134.         break;
  1135.         case GREATER:
  1136.         if (valuePtr->type == TYPE_INT) {
  1137.             valuePtr->intValue =
  1138.             valuePtr->intValue > value2.intValue;
  1139.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1140.             valuePtr->intValue =
  1141.             valuePtr->doubleValue > value2.doubleValue;
  1142.         } else {
  1143.             valuePtr->intValue =
  1144.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0;
  1145.         }
  1146.         valuePtr->type = TYPE_INT;
  1147.         break;
  1148.         case LEQ:
  1149.         if (valuePtr->type == TYPE_INT) {
  1150.             valuePtr->intValue =
  1151.             valuePtr->intValue <= value2.intValue;
  1152.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1153.             valuePtr->intValue =
  1154.             valuePtr->doubleValue <= value2.doubleValue;
  1155.         } else {
  1156.             valuePtr->intValue =
  1157.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0;
  1158.         }
  1159.         valuePtr->type = TYPE_INT;
  1160.         break;
  1161.         case GEQ:
  1162.         if (valuePtr->type == TYPE_INT) {
  1163.             valuePtr->intValue =
  1164.             valuePtr->intValue >= value2.intValue;
  1165.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1166.             valuePtr->intValue =
  1167.             valuePtr->doubleValue >= value2.doubleValue;
  1168.         } else {
  1169.             valuePtr->intValue =
  1170.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0;
  1171.         }
  1172.         valuePtr->type = TYPE_INT;
  1173.         break;
  1174.         case EQUAL:
  1175.         if (valuePtr->type == TYPE_INT) {
  1176.             valuePtr->intValue =
  1177.             valuePtr->intValue == value2.intValue;
  1178.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1179.             valuePtr->intValue =
  1180.             valuePtr->doubleValue == value2.doubleValue;
  1181.         } else {
  1182.             valuePtr->intValue =
  1183.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0;
  1184.         }
  1185.         valuePtr->type = TYPE_INT;
  1186.         break;
  1187.         case NEQ:
  1188.         if (valuePtr->type == TYPE_INT) {
  1189.             valuePtr->intValue =
  1190.             valuePtr->intValue != value2.intValue;
  1191.         } else if (valuePtr->type == TYPE_DOUBLE) {
  1192.             valuePtr->intValue =
  1193.             valuePtr->doubleValue != value2.doubleValue;
  1194.         } else {
  1195.             valuePtr->intValue =
  1196.                 strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0;
  1197.         }
  1198.         valuePtr->type = TYPE_INT;
  1199.         break;
  1200.         case BIT_AND:
  1201.         valuePtr->intValue &= value2.intValue;
  1202.         break;
  1203.         case BIT_XOR:
  1204.         valuePtr->intValue ^= value2.intValue;
  1205.         break;
  1206.         case BIT_OR:
  1207.         valuePtr->intValue |= value2.intValue;
  1208.         break;
  1209.  
  1210.         /*
  1211.          * For AND and OR, we know that the first value has already
  1212.          * been converted to an integer.  Thus we need only consider
  1213.          * the possibility of int vs. double for the second value.
  1214.          */
  1215.  
  1216.         case AND:
  1217.         if (value2.type == TYPE_DOUBLE) {
  1218.             value2.intValue = value2.doubleValue != 0;
  1219.             value2.type = TYPE_INT;
  1220.         }
  1221.         valuePtr->intValue = valuePtr->intValue && value2.intValue;
  1222.         break;
  1223.         case OR:
  1224.         if (value2.type == TYPE_DOUBLE) {
  1225.             value2.intValue = value2.doubleValue != 0;
  1226.             value2.type = TYPE_INT;
  1227.         }
  1228.         valuePtr->intValue = valuePtr->intValue || value2.intValue;
  1229.         break;
  1230.  
  1231.         case COLON:
  1232.         interp->result = "can't have : operator without ? first";
  1233.         result = TCL_ERROR;
  1234.         goto done;
  1235.     }
  1236.     }
  1237.  
  1238.     done:
  1239.     if (value2.pv.buffer != value2.staticSpace) {
  1240.     ckfree(value2.pv.buffer);
  1241.     }
  1242.     return result;
  1243.  
  1244.     syntaxError:
  1245.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1246.         infoPtr->originalExpr, "\"", (char *) NULL);
  1247.     result = TCL_ERROR;
  1248.     goto done;
  1249.  
  1250.     illegalType:
  1251.     Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ?
  1252.         "floating-point value" : "non-numeric string",
  1253.         " as operand of \"", operatorStrings[operator], "\"",
  1254.         (char *) NULL);
  1255.     result = TCL_ERROR;
  1256.     goto done;
  1257. }
  1258.  
  1259. /*
  1260.  *--------------------------------------------------------------
  1261.  *
  1262.  * ExprMakeString --
  1263.  *
  1264.  *    Convert a value from int or double representation to
  1265.  *    a string.
  1266.  *
  1267.  * Results:
  1268.  *    The information at *valuePtr gets converted to string
  1269.  *    format, if it wasn't that way already.
  1270.  *
  1271.  * Side effects:
  1272.  *    None.
  1273.  *
  1274.  *--------------------------------------------------------------
  1275.  */
  1276.  
  1277. static void
  1278. ExprMakeString(interp, valuePtr)
  1279.     Tcl_Interp *interp;            /* Interpreter to use for precision
  1280.                      * information. */
  1281.     register Value *valuePtr;        /* Value to be converted. */
  1282. {
  1283.     int shortfall;
  1284.  
  1285.     shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer);
  1286.     if (shortfall > 0) {
  1287.     (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
  1288.     }
  1289.     if (valuePtr->type == TYPE_INT) {
  1290.     sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue);
  1291.     } else if (valuePtr->type == TYPE_DOUBLE) {
  1292.     Tcl_PrintDouble(interp, valuePtr->doubleValue, valuePtr->pv.buffer);
  1293.     }
  1294.     valuePtr->type = TYPE_STRING;
  1295. }
  1296.  
  1297. /*
  1298.  *--------------------------------------------------------------
  1299.  *
  1300.  * ExprTopLevel --
  1301.  *
  1302.  *    This procedure provides top-level functionality shared by
  1303.  *    procedures like Tcl_ExprInt, Tcl_ExprDouble, etc.
  1304.  *
  1305.  * Results:
  1306.  *    The result is a standard Tcl return value.  If an error
  1307.  *    occurs then an error message is left in interp->result.
  1308.  *    The value of the expression is returned in *valuePtr, in
  1309.  *    whatever form it ends up in (could be string or integer
  1310.  *    or double).  Caller may need to convert result.  Caller
  1311.  *    is also responsible for freeing string memory in *valuePtr,
  1312.  *    if any was allocated.
  1313.  *
  1314.  * Side effects:
  1315.  *    None.
  1316.  *
  1317.  *--------------------------------------------------------------
  1318.  */
  1319.  
  1320. static int
  1321. ExprTopLevel(interp, string, valuePtr)
  1322.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1323.                      * expression. */
  1324.     char *string;            /* Expression to evaluate. */
  1325.     Value *valuePtr;            /* Where to store result.  Should
  1326.                      * not be initialized by caller. */
  1327. {
  1328.     ExprInfo info;
  1329.     int result;
  1330.  
  1331.     /*
  1332.      * Create the math functions the first time an expression is
  1333.      * evaluated.
  1334.      */
  1335.  
  1336.     if (!(((Interp *) interp)->flags & EXPR_INITIALIZED)) {
  1337.     BuiltinFunc *funcPtr;
  1338.  
  1339.     ((Interp *) interp)->flags |= EXPR_INITIALIZED;
  1340.     for (funcPtr = funcTable; funcPtr->name != NULL;
  1341.         funcPtr++) {
  1342.         Tcl_CreateMathFunc(interp, funcPtr->name, funcPtr->numArgs,
  1343.             funcPtr->argTypes, funcPtr->proc, funcPtr->clientData);
  1344.     }
  1345.     }
  1346.  
  1347.     info.originalExpr = string;
  1348.     info.expr = string;
  1349.     valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace;
  1350.     valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1;
  1351.     valuePtr->pv.expandProc = TclExpandParseValue;
  1352.     valuePtr->pv.clientData = (ClientData) NULL;
  1353.  
  1354.     result = ExprGetValue(interp, &info, -1, valuePtr);
  1355.     if (result != TCL_OK) {
  1356.     return result;
  1357.     }
  1358.     if (info.token != END) {
  1359.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1360.         string, "\"", (char *) NULL);
  1361.     return TCL_ERROR;
  1362.     }
  1363.     if ((valuePtr->type == TYPE_DOUBLE) && (IS_NAN(valuePtr->doubleValue)
  1364.         || IS_INF(valuePtr->doubleValue))) {
  1365.     /*
  1366.      * IEEE floating-point error.
  1367.      */
  1368.  
  1369.     ExprFloatError(interp, valuePtr->doubleValue);
  1370.     return TCL_ERROR;
  1371.     }
  1372.     return TCL_OK;
  1373. }
  1374.  
  1375. /*
  1376.  *--------------------------------------------------------------
  1377.  *
  1378.  * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
  1379.  *
  1380.  *    Procedures to evaluate an expression and return its value
  1381.  *    in a particular form.
  1382.  *
  1383.  * Results:
  1384.  *    Each of the procedures below returns a standard Tcl result.
  1385.  *    If an error occurs then an error message is left in
  1386.  *    interp->result.  Otherwise the value of the expression,
  1387.  *    in the appropriate form, is stored at *resultPtr.  If
  1388.  *    the expression had a result that was incompatible with the
  1389.  *    desired form then an error is returned.
  1390.  *
  1391.  * Side effects:
  1392.  *    None.
  1393.  *
  1394.  *--------------------------------------------------------------
  1395.  */
  1396.  
  1397. int
  1398. Tcl_ExprLong(interp, string, ptr)
  1399.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1400.                      * expression. */
  1401.     char *string;            /* Expression to evaluate. */
  1402.     long *ptr;                /* Where to store result. */
  1403. {
  1404.     Value value;
  1405.     int result;
  1406.  
  1407.     result = ExprTopLevel(interp, string, &value);
  1408.     if (result == TCL_OK) {
  1409.     if (value.type == TYPE_INT) {
  1410.         *ptr = value.intValue;
  1411.     } else if (value.type == TYPE_DOUBLE) {
  1412.         *ptr = value.doubleValue;
  1413.     } else {
  1414.         interp->result = "expression didn't have numeric value";
  1415.         result = TCL_ERROR;
  1416.     }
  1417.     }
  1418.     if (value.pv.buffer != value.staticSpace) {
  1419.     ckfree(value.pv.buffer);
  1420.     }
  1421.     return result;
  1422. }
  1423.  
  1424. int
  1425. Tcl_ExprDouble(interp, string, ptr)
  1426.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1427.                      * expression. */
  1428.     char *string;            /* Expression to evaluate. */
  1429.     double *ptr;            /* Where to store result. */
  1430. {
  1431.     Value value;
  1432.     int result;
  1433.  
  1434.     result = ExprTopLevel(interp, string, &value);
  1435.     if (result == TCL_OK) {
  1436.     if (value.type == TYPE_INT) {
  1437.         *ptr = value.intValue;
  1438.     } else if (value.type == TYPE_DOUBLE) {
  1439.         *ptr = value.doubleValue;
  1440.     } else {
  1441.         interp->result = "expression didn't have numeric value";
  1442.         result = TCL_ERROR;
  1443.     }
  1444.     }
  1445.     if (value.pv.buffer != value.staticSpace) {
  1446.     ckfree(value.pv.buffer);
  1447.     }
  1448.     return result;
  1449. }
  1450.  
  1451. int
  1452. Tcl_ExprBoolean(interp, string, ptr)
  1453.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1454.                      * expression. */
  1455.     char *string;            /* Expression to evaluate. */
  1456.     int *ptr;                /* Where to store 0/1 result. */
  1457. {
  1458.     Value value;
  1459.     int result;
  1460.  
  1461.     result = ExprTopLevel(interp, string, &value);
  1462.     if (result == TCL_OK) {
  1463.     if (value.type == TYPE_INT) {
  1464.         *ptr = value.intValue != 0;
  1465.     } else if (value.type == TYPE_DOUBLE) {
  1466.         *ptr = value.doubleValue != 0.0;
  1467.     } else {
  1468.         result = Tcl_GetBoolean(interp, value.pv.buffer, ptr);
  1469.     }
  1470.     }
  1471.     if (value.pv.buffer != value.staticSpace) {
  1472.     ckfree(value.pv.buffer);
  1473.     }
  1474.     return result;
  1475. }
  1476.  
  1477. /*
  1478.  *--------------------------------------------------------------
  1479.  *
  1480.  * Tcl_ExprString --
  1481.  *
  1482.  *    Evaluate an expression and return its value in string form.
  1483.  *
  1484.  * Results:
  1485.  *    A standard Tcl result.  If the result is TCL_OK, then the
  1486.  *    interpreter's result is set to the string value of the
  1487.  *    expression.  If the result is TCL_OK, then interp->result
  1488.  *    contains an error message.
  1489.  *
  1490.  * Side effects:
  1491.  *    None.
  1492.  *
  1493.  *--------------------------------------------------------------
  1494.  */
  1495.  
  1496. int
  1497. Tcl_ExprString(interp, string)
  1498.     Tcl_Interp *interp;            /* Context in which to evaluate the
  1499.                      * expression. */
  1500.     char *string;            /* Expression to evaluate. */
  1501. {
  1502.     Value value;
  1503.     int result;
  1504.  
  1505.     result = ExprTopLevel(interp, string, &value);
  1506.     if (result == TCL_OK) {
  1507.     if (value.type == TYPE_INT) {
  1508.         sprintf(interp->result, "%ld", value.intValue);
  1509.     } else if (value.type == TYPE_DOUBLE) {
  1510.         Tcl_PrintDouble(interp, value.doubleValue, interp->result);
  1511.     } else {
  1512.         if (value.pv.buffer != value.staticSpace) {
  1513.         interp->result = value.pv.buffer;
  1514.         interp->freeProc = (Tcl_FreeProc *) free;
  1515.         value.pv.buffer = value.staticSpace;
  1516.         } else {
  1517.         Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE);
  1518.         }
  1519.     }
  1520.     }
  1521.     if (value.pv.buffer != value.staticSpace) {
  1522.     ckfree(value.pv.buffer);
  1523.     }
  1524.     return result;
  1525. }
  1526.  
  1527. /*
  1528.  *----------------------------------------------------------------------
  1529.  *
  1530.  * Tcl_CreateMathFunc --
  1531.  *
  1532.  *    Creates a new math function for expressions in a given
  1533.  *    interpreter.
  1534.  *
  1535.  * Results:
  1536.  *    None.
  1537.  *
  1538.  * Side effects:
  1539.  *    The function defined by "name" is created;  if such a function
  1540.  *    already existed then its definition is overriden.
  1541.  *
  1542.  *----------------------------------------------------------------------
  1543.  */
  1544.  
  1545. void
  1546. Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
  1547.     Tcl_Interp *interp;            /* Interpreter in which function is
  1548.                      * to be available. */
  1549.     char *name;                /* Name of function (e.g. "sin"). */
  1550.     int numArgs;            /* Nnumber of arguments required by
  1551.                      * function. */
  1552.     Tcl_ValueType *argTypes;        /* Array of types acceptable for
  1553.                      * each argument. */
  1554.     Tcl_MathProc *proc;            /* Procedure that implements the
  1555.                      * math function. */
  1556.     ClientData clientData;        /* Additional value to pass to the
  1557.                      * function. */
  1558. {
  1559.     Interp *iPtr = (Interp *) interp;
  1560.     Tcl_HashEntry *hPtr;
  1561.     MathFunc *mathFuncPtr;
  1562.     int new, i;
  1563.  
  1564.     hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
  1565.     if (new) {
  1566.     Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
  1567.     }
  1568.     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
  1569.     mathFuncPtr->numArgs = numArgs;
  1570.     for (i = 0; i < numArgs; i++) {
  1571.     mathFuncPtr->argTypes[i] = argTypes[i];
  1572.     }
  1573.     mathFuncPtr->proc = proc;
  1574.     mathFuncPtr->clientData = clientData;
  1575. }
  1576.  
  1577. /*
  1578.  *----------------------------------------------------------------------
  1579.  *
  1580.  * ExprMathFunc --
  1581.  *
  1582.  *    This procedure is invoked to parse a math function from an
  1583.  *    expression string, carry out the function, and return the
  1584.  *    value computed.
  1585.  *
  1586.  * Results:
  1587.  *    TCL_OK is returned if all went well and the function's value
  1588.  *    was computed successfully.  If an error occurred, TCL_ERROR
  1589.  *    is returned and an error message is left in interp->result.
  1590.  *    After a successful return infoPtr has been updated to refer
  1591.  *    to the character just after the function call, the token is
  1592.  *    set to VALUE, and the value is stored in valuePtr.
  1593.  *
  1594.  * Side effects:
  1595.  *    Embedded commands could have arbitrary side-effects.
  1596.  *
  1597.  *----------------------------------------------------------------------
  1598.  */
  1599.  
  1600. static int
  1601. ExprMathFunc(interp, infoPtr, valuePtr)
  1602.     Tcl_Interp *interp;            /* Interpreter to use for error
  1603.                      * reporting. */
  1604.     register ExprInfo *infoPtr;        /* Describes the state of the parse.
  1605.                      * infoPtr->expr must point to the
  1606.                      * first character of the function's
  1607.                      * name. */
  1608.     register Value *valuePtr;        /* Where to store value, if that is
  1609.                      * what's parsed from string.  Caller
  1610.                      * must have initialized pv field
  1611.                      * correctly. */
  1612. {
  1613.     Interp *iPtr = (Interp *) interp;
  1614.     MathFunc *mathFuncPtr;        /* Info about math function. */
  1615.     Tcl_Value args[MAX_MATH_ARGS];    /* Arguments for function call. */
  1616.     Tcl_Value funcResult;        /* Result of function call. */
  1617.     Tcl_HashEntry *hPtr;
  1618.     char *p, *funcName;
  1619.     int i, savedChar, result;
  1620.  
  1621.     /*
  1622.      * Find the end of the math function's name and lookup the MathFunc
  1623.      * record for the function.
  1624.      */
  1625.  
  1626.     p = funcName = infoPtr->expr;
  1627.     while (isalnum(*p) || (*p == '_')) {
  1628.     p++;
  1629.     }
  1630.     infoPtr->expr = p;
  1631.     result = ExprLex(interp, infoPtr, valuePtr);
  1632.     if (infoPtr->token != OPEN_PAREN) {
  1633.     goto syntaxError;
  1634.     }
  1635.     savedChar = *p;
  1636.     *p = 0;
  1637.     hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
  1638.     if (hPtr == NULL) {
  1639.     Tcl_AppendResult(interp, "unknown math function \"", funcName,
  1640.         "\"", (char *) NULL);
  1641.     *p = savedChar;
  1642.     return TCL_ERROR;
  1643.     }
  1644.     *p = savedChar;
  1645.     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
  1646.  
  1647.     /*
  1648.      * Scan off the arguments for the function.
  1649.      */
  1650.  
  1651.     for (i = 0; i < mathFuncPtr->numArgs; i++) {
  1652.     valuePtr->pv.next = valuePtr->pv.buffer;
  1653.     result = ExprGetValue(interp, infoPtr, -1, valuePtr);
  1654.     if (result != TCL_OK) {
  1655.         return result;
  1656.     }
  1657.     if (valuePtr->type == TYPE_STRING) {
  1658.         interp->result =
  1659.             "argument to math function didn't have numeric value";
  1660.         return TCL_ERROR;
  1661.     }
  1662.  
  1663.     /*
  1664.      * Copy the value to the argument record, converting it if
  1665.      * necessary.
  1666.      */
  1667.  
  1668.     if (valuePtr->type == TYPE_INT) {
  1669.         if (mathFuncPtr->argTypes[i] == TCL_DOUBLE) {
  1670.         args[i].type = TCL_DOUBLE;
  1671.         args[i].doubleValue = valuePtr->intValue;
  1672.         } else {
  1673.         args[i].type = TCL_INT;
  1674.         args[i].intValue = valuePtr->intValue;
  1675.         }
  1676.     } else {
  1677.         if (mathFuncPtr->argTypes[i] == TCL_INT) {
  1678.         args[i].type = TCL_INT;
  1679.         args[i].intValue = valuePtr->doubleValue;
  1680.         } else {
  1681.         args[i].type = TCL_DOUBLE;
  1682.         args[i].doubleValue = valuePtr->doubleValue;
  1683.         }
  1684.     }
  1685.  
  1686.     /*
  1687.      * Check for a comma separator between arguments or a close-paren
  1688.      * to end the argument list.
  1689.      */
  1690.  
  1691.     if (i == (mathFuncPtr->numArgs-1)) {
  1692.         if (infoPtr->token == CLOSE_PAREN) {
  1693.         break;
  1694.         }
  1695.         if (infoPtr->token == COMMA) {
  1696.         interp->result = "too many arguments for math function";
  1697.         return TCL_ERROR;
  1698.         } else {
  1699.         goto syntaxError;
  1700.         }
  1701.     }
  1702.     if (infoPtr->token != COMMA) {
  1703.         if (infoPtr->token == CLOSE_PAREN) {
  1704.         interp->result = "too few arguments for math function";
  1705.         return TCL_ERROR;
  1706.         } else {
  1707.         goto syntaxError;
  1708.         }
  1709.     }
  1710.     }
  1711.  
  1712.     /*
  1713.      * Invoke the function and copy its result back into valuePtr.
  1714.      */
  1715.  
  1716.     tcl_MathInProgress++;
  1717.     result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
  1718.         &funcResult);
  1719.     tcl_MathInProgress--;
  1720.     if (result != TCL_OK) {
  1721.     return result;
  1722.     }
  1723.     if (funcResult.type == TCL_INT) {
  1724.     valuePtr->type = TYPE_INT;
  1725.     valuePtr->intValue = funcResult.intValue;
  1726.     } else {
  1727.     valuePtr->type = TYPE_DOUBLE;
  1728.     valuePtr->doubleValue = funcResult.doubleValue;
  1729.     }
  1730.     infoPtr->token = VALUE;
  1731.     return TCL_OK;
  1732.  
  1733.     syntaxError:
  1734.     Tcl_AppendResult(interp, "syntax error in expression \"",
  1735.         infoPtr->originalExpr, "\"", (char *) NULL);
  1736.     return TCL_ERROR;
  1737. }
  1738.  
  1739. /*
  1740.  *----------------------------------------------------------------------
  1741.  *
  1742.  * ExprFloatError --
  1743.  *
  1744.  *    This procedure is called when an error occurs during a
  1745.  *    floating-point operation.  It reads errno and sets
  1746.  *    interp->result accordingly.
  1747.  *
  1748.  * Results:
  1749.  *    Interp->result is set to hold an error message.
  1750.  *
  1751.  * Side effects:
  1752.  *    None.
  1753.  *
  1754.  *----------------------------------------------------------------------
  1755.  */
  1756.  
  1757. static void
  1758. ExprFloatError(interp, value)
  1759.     Tcl_Interp *interp;        /* Where to store error message. */
  1760.     double value;        /* Value returned after error;  used to
  1761.                  * distinguish underflows from overflows. */
  1762. {
  1763.     char buf[20];
  1764.  
  1765.     if ((errno == EDOM) || (value != value)) {
  1766.     interp->result = "domain error: argument not in valid range";
  1767.     Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", interp->result,
  1768.         (char *) NULL);
  1769.     } else if ((errno == ERANGE) || IS_INF(value)) {
  1770.     if (value == 0.0) {
  1771.         interp->result = "floating-point value too small to represent";
  1772.         Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", interp->result,
  1773.             (char *) NULL);
  1774.     } else {
  1775.         interp->result = "floating-point value too large to represent";
  1776.         Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", interp->result,
  1777.             (char *) NULL);
  1778.     }
  1779.     } else {
  1780.     sprintf(buf, "%d", errno);
  1781.     Tcl_AppendResult(interp, "unknown floating-point error, ",
  1782.         "errno = ", buf, (char *) NULL);
  1783.     Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", interp->result,
  1784.         (char *) NULL);
  1785.     }
  1786. }
  1787.  
  1788. /*
  1789.  *----------------------------------------------------------------------
  1790.  *
  1791.  * Math Functions --
  1792.  *
  1793.  *    This page contains the procedures that implement all of the
  1794.  *    built-in math functions for expressions.
  1795.  *
  1796.  * Results:
  1797.  *    Each procedure returns TCL_OK if it succeeds and places result
  1798.  *    information at *resultPtr.  If it fails it returns TCL_ERROR
  1799.  *    and leaves an error message in interp->result.
  1800.  *
  1801.  * Side effects:
  1802.  *    None.
  1803.  *
  1804.  *----------------------------------------------------------------------
  1805.  */
  1806.  
  1807. static int
  1808. ExprUnaryFunc(clientData, interp, args, resultPtr)
  1809.     ClientData clientData;        /* Contains address of procedure that
  1810.                      * takes one double argument and
  1811.                      * returns a double result. */
  1812.     Tcl_Interp *interp;
  1813.     Tcl_Value *args;
  1814.     Tcl_Value *resultPtr;
  1815. {
  1816.     double (*func)() = (double (*)()) clientData;
  1817.  
  1818.     errno = 0;
  1819.     resultPtr->type = TCL_DOUBLE;
  1820.     resultPtr->doubleValue = (*func)(args[0].doubleValue);
  1821.     if (errno != 0) {
  1822.     ExprFloatError(interp, resultPtr->doubleValue);
  1823.     return TCL_ERROR;
  1824.     }
  1825.     return TCL_OK;
  1826. }
  1827.  
  1828. static int
  1829. ExprBinaryFunc(clientData, interp, args, resultPtr)
  1830.     ClientData clientData;        /* Contains address of procedure that
  1831.                      * takes two double arguments and
  1832.                      * returns a double result. */
  1833.     Tcl_Interp *interp;
  1834.     Tcl_Value *args;
  1835.     Tcl_Value *resultPtr;
  1836. {
  1837.     double (*func)() = (double (*)()) clientData;
  1838.  
  1839.     errno = 0;
  1840.     resultPtr->type = TCL_DOUBLE;
  1841.     resultPtr->doubleValue = (*func)(args[0].doubleValue, args[1].doubleValue);
  1842.     if (errno != 0) {
  1843.     ExprFloatError(interp, resultPtr->doubleValue);
  1844.     return TCL_ERROR;
  1845.     }
  1846.     return TCL_OK;
  1847. }
  1848.  
  1849.     /* ARGSUSED */
  1850. static int
  1851. ExprAbsFunc(clientData, interp, args, resultPtr)
  1852.     ClientData clientData;
  1853.     Tcl_Interp *interp;
  1854.     Tcl_Value *args;
  1855.     Tcl_Value *resultPtr;
  1856. {
  1857.     resultPtr->type = TCL_DOUBLE;
  1858.     if (args[0].type == TCL_DOUBLE) {
  1859.     resultPtr->type = TCL_DOUBLE;
  1860.     if (args[0].doubleValue < 0) {
  1861.         resultPtr->doubleValue = -args[0].doubleValue;
  1862.     } else {
  1863.         resultPtr->doubleValue = args[0].doubleValue;
  1864.     }
  1865.     } else {
  1866.     resultPtr->type = TCL_INT;
  1867.     if (args[0].intValue < 0) {
  1868.         resultPtr->intValue = -args[0].intValue;
  1869.         if (resultPtr->intValue < 0) {
  1870.         interp->result = "integer value too large to represent";
  1871.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result,
  1872.             (char *) NULL);
  1873.         return TCL_ERROR;
  1874.         }
  1875.     } else {
  1876.         resultPtr->intValue = args[0].intValue;
  1877.     }
  1878.     }
  1879.     return TCL_OK;
  1880. }
  1881.  
  1882.     /* ARGSUSED */
  1883. static int
  1884. ExprDoubleFunc(clientData, interp, args, resultPtr)
  1885.     ClientData clientData;
  1886.     Tcl_Interp *interp;
  1887.     Tcl_Value *args;
  1888.     Tcl_Value *resultPtr;
  1889. {
  1890.     resultPtr->type = TCL_DOUBLE;
  1891.     if (args[0].type == TCL_DOUBLE) {
  1892.     resultPtr->doubleValue = args[0].doubleValue;
  1893.     } else {
  1894.     resultPtr->doubleValue = args[0].intValue;
  1895.     }
  1896.     return TCL_OK;
  1897. }
  1898.  
  1899.     /* ARGSUSED */
  1900. static int
  1901. ExprIntFunc(clientData, interp, args, resultPtr)
  1902.     ClientData clientData;
  1903.     Tcl_Interp *interp;
  1904.     Tcl_Value *args;
  1905.     Tcl_Value *resultPtr;
  1906. {
  1907.     resultPtr->type = TCL_INT;
  1908.     if (args[0].type == TCL_INT) {
  1909.     resultPtr->intValue = args[0].intValue;
  1910.     } else {
  1911.     if (args[0].doubleValue < 0) {
  1912.         if (args[0].doubleValue < (double) (long) LONG_MIN) {
  1913.         tooLarge:
  1914.         interp->result = "integer value too large to represent";
  1915.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  1916.             interp->result, (char *) NULL);
  1917.         return TCL_ERROR;
  1918.         }
  1919.     } else {
  1920.         if (args[0].doubleValue > (double) LONG_MAX) {
  1921.         goto tooLarge;
  1922.         }
  1923.     }
  1924.     resultPtr->intValue = args[0].doubleValue;
  1925.     }
  1926.     return TCL_OK;
  1927. }
  1928.  
  1929.     /* ARGSUSED */
  1930. static int
  1931. ExprRoundFunc(clientData, interp, args, resultPtr)
  1932.     ClientData clientData;
  1933.     Tcl_Interp *interp;
  1934.     Tcl_Value *args;
  1935.     Tcl_Value *resultPtr;
  1936. {
  1937.     resultPtr->type = TCL_INT;
  1938.     if (args[0].type == TCL_INT) {
  1939.     resultPtr->intValue = args[0].intValue;
  1940.     } else {
  1941.     if (args[0].doubleValue < 0) {
  1942.         if (args[0].doubleValue <= (((double) (long) LONG_MIN) - 0.5)) {
  1943.         tooLarge:
  1944.         interp->result = "integer value too large to represent";
  1945.         Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
  1946.             interp->result, (char *) NULL);
  1947.         return TCL_ERROR;
  1948.         }
  1949.         resultPtr->intValue = (args[0].doubleValue - 0.5);
  1950.     } else {
  1951.         if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) {
  1952.         goto tooLarge;
  1953.         }
  1954.         resultPtr->intValue = (args[0].doubleValue + 0.5);
  1955.     }
  1956.     }
  1957.     return TCL_OK;
  1958. }
  1959.